home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / examples / cmd-frame.lisp next >
Text File  |  1990-07-19  |  6KB  |  161 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                             AUSTIN, TEXAS 78714-9149                             |
  9. ;;;                                                                                  |
  10. ;;;              Copyright (C) 1989, 1990 Texas Instruments Incorporated.            |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package "CLIO-OPEN")
  22.  
  23. (export '(
  24.       command-frame
  25.       command-frame-content
  26.       command-frame-controls
  27.       make-command-frame
  28.       )
  29.     'clio-open)
  30.  
  31.  
  32. (defcontact command-frame (core core-shell top-level-session)
  33.   ()
  34.   (:documentation "A  top-level-session containing a content and a set of controls.")
  35.   (:resources
  36.     (content  :type (or function list) :initform nil)
  37.     (controls :type (or function list) :initform nil)))
  38.  
  39.  
  40. (defmethod initialize-instance :after ((command-frame command-frame)
  41.                        &rest initargs &key content controls)
  42.   (with-slots (width height) command-frame
  43.     
  44.     ;; Initialize command-frame-form
  45.     (assert content () "No content defined for ~a." command-frame)
  46.     (multiple-value-bind (content-constructor content-initargs)
  47.     (etypecase content
  48.       (function content)
  49.       (list (values (first content) (rest content))))
  50.     
  51.       (let*
  52.     ((content-name     (or (getf content-initargs :name) :content))
  53.      (hlinks           `((
  54.                   :from        :command-frame-form
  55.                   :to          ,content-name
  56.                   :attach-from :left
  57.                   :attach-to   :left
  58.                   :maximum     0)
  59.                  (
  60.                   :from        ,content-name
  61.                   :to          :command-frame-form
  62.                   :attach-from :right
  63.                   :attach-to   :right
  64.                   :maximum     0)
  65.                  (
  66.                   :from        :command-frame-form
  67.                   :to          :controls
  68.                   :attach-from :left
  69.                   :attach-to   :left
  70.                   :maximum     0)
  71.                  (
  72.                   :from        :controls
  73.                   :to          :command-frame-form
  74.                   :attach-from :right
  75.                   :attach-to   :right
  76.                   :maximum     0)))
  77.      (vlinks           `((
  78.                   :from        :command-frame-form
  79.                   :to          :controls
  80.                   :attach-from :top
  81.                   :attach-to   :top
  82.                   :maximum     0)
  83.                  (
  84.                   :from        :controls
  85.                   :to          ,content-name
  86.                   :maximum     0)
  87.                  (
  88.                   :from        ,content-name
  89.                   :to          :command-frame-form
  90.                   :attach-from :bottom
  91.                   :attach-to   :bottom
  92.                   :maximum     0)
  93.                  ))
  94.      (form             (make-form
  95.                  :name             :command-frame-form
  96.                  :parent           command-frame
  97.                  :width            width
  98.                  :height           height
  99.                  :horizontal-links hlinks
  100.                  :vertical-links   vlinks)))
  101.     
  102.     ;; Initialize content 
  103.     (apply content-constructor
  104.            :name       content-name
  105.            :parent     form
  106.            :max-height :infinite
  107.            :min-height 0
  108.            :max-width  :infinite
  109.            :min-width  0                  
  110.            content-initargs)
  111.     
  112.     ;; Initialize controls area
  113.     (multiple-value-bind (controls-constructor controls-initargs)
  114.         (etypecase controls
  115.           (null
  116.            (let ((space (point-pixels
  117.                   (contact-screen command-frame)
  118.                   (getf *dialog-point-spacing* (contact-scale command-frame)))))
  119.          (values 'make-table 
  120.              `(
  121.                :columns              :maximum
  122.                :column-alignment     :center
  123.                :same-height-in-row   :on
  124.                :horizontal-space     ,space
  125.                :left-margin          ,space
  126.                :right-margin         ,space
  127.                :top-margin           ,(pixel-round space 2)
  128.                :bottom-margin        ,(pixel-round space 2)))))
  129.           
  130.           (function controls)
  131.           
  132.           (list (values (first controls) (rest controls))))
  133.       
  134.       (apply controls-constructor 
  135.          :parent       form
  136.          :name         :controls
  137.          :border-width 0
  138.          :max-width    :infinite
  139.          :min-width    0
  140.          controls-initargs))))))
  141.  
  142.  
  143. (defun command-frame-form (command-frame)
  144.   (first (slot-value command-frame 'children)))
  145.  
  146. (defmethod command-frame-content ((command-frame command-frame))
  147.   (first (slot-value (command-frame-form command-frame) 'children)))
  148.  
  149. (defmethod command-frame-controls ((command-frame command-frame))
  150.   (second (slot-value (command-frame-form command-frame) 'children)))
  151.  
  152. (defun make-command-frame (&rest initargs)
  153.   (apply #'make-contact 'command-frame initargs))
  154.  
  155. (defmethod rescale :before ((command-frame command-frame))
  156.   (let ((controls (command-frame-controls command-frame)))
  157.     (multiple-value-bind (pw ph) (preferred-size controls)
  158.       (declare (ignore pw))
  159.       (setf (form-max-height controls) (setf (form-min-height controls) ph)))))
  160.  
  161.